perm filename XREST.F4[RST,LCS] blob
sn#205524 filedate 1976-03-05 generic text, type T, neo UTF8
00100 C******* SUBRS TAIL, FERMTA, REST, BREP, EXCH, SORT2, NOZERO,
00300 SUBROUTINE TAIL
00400 COMMON/ALF/INP(49),RMINI,RINV,RA,RX,RJX,NONO(19)
00500 COMMON /STF/RSTFAC(8),RSTJ2 /PLTR/IPLT,RHT,DIS
00600 DIMENSION ITAIL(16)
00700 DATA ITAIL/16,100090007,110012,120016,200120016,120019,100026,
00800 1 80030,20036, 40, 33, 30031, 50029,80025,100022,120016/
00900 CALL CENTER(RJY)
01000 Q=-1.
01100 IF(RA)Q=1.
01200 IF(IPLT)GO TO 2
01300 ITAIL(1)=10
01400 1 CALL JDRAW(ITAIL,RJX,RJY,RMINI,1.,Q)
01500 RETURN
01600 2 P=Q
01700 IF(RMINI.NE.RSTJ2)P=P*.6
01800 ITAIL(1)=16
01900 CALL FILLMS(12,ITAIL(5),RJX,RJY,ABS(P),P)
02000 C RA=-,STEM UP; RA=+, STEM DOWN.
02100 GO TO 1
02200 END
02300
02400 SUBROUTINE REST
02500 COMMON /STF/RSTFAC(8),RSTJ2/PLTR/IPLT,RHT,DIS
02600 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
02700 EQUIVALENCE(J5,JQ(3)),(R3,RJQ(1)),(R4,RJQ(2)),(R7,RJQ(5))
02800 1,(R6,RJQ(4)),(R8,RJQ(6)),(R5,RJQ(3)),(R10,RJQ(8)),(J4,JQ(2))
02805 1,(R9,RJQ(7)),(RA,JQ(4)),(RB,JQ(5))
02900 DIMENSION LRST(3),IRST(47),MR(2),MF(2)
03000 DATA IRST/9,100000033,160033,160030, 30,32 ,160032 ,160031,
03100 1 31, 23,100000051,100038,32,110017,200050044, 32 ,50026,
03200 1 100038,50044,100110017,70018,50017,50015,60011, 10016,
03300 1 18, 20,10022,30023, 50023, 70022,110017,
03400 1 15,100030033, 40032, 80032,120035,150039,70014,200010037,
03500 1 30039, 50039, 70037, 70035, 50033, 30033,10035/
03600 1,LRST/1,10,33/,MR/18,8/,MF/15,40/
03700 C LRST = BEGINNING OF EACH REST, MR=FILLER WDCNT, MF=FILL START.
03800
03900 L=J5
04000 IF(L.GT.1)L=1
04100 IF(L)L=-1
04200 C L>3 WHEN SEVERAL TAILS ON REST
04300 R10=RSTJ2
04400 IF(IABS(J4).LT.80)GO TO 2
04500 C NEXT FOR MINI-RESTS
04600 RSTJ2=RSTJ2*.7
04700 J4=0
04800 R4=R4+2.
04900 2 CALL CENTER(CENTR)
04910 RA=1.
04920 RB=R3
05000 IF(J5.NE.-3)GO TO 9
05005 C -3 IN P5 = DOUBLE WHOLE REST.
05010 J5=-5
05020 RA=2.
05030 RB=RB-8*RSTJ2
05040 C TO CENTER THE DOUBLE WHOLE REST.
05200 9 IF(J5.LE.-2)CENTR=CENTR+9.4*R10
05300 C CENTERS WHOLE REST
05400 5 CALL JDRAW(IRST(LRST(L+2)),RB,CENTR,RSTJ2,RA,1.)
05500 IF(J5.GT.-3)GO TO 4
05600 J5=J5+1
05700 CENTR=CENTR-3.133*R10
05800 GO TO 5
05810 4 IF(J5.GE.0)GO TO 6
05820 CHECK FOR NEED OF LEDGER LINES (1/2 AND WHOLE RESTS)(NOT FOR DBLS).
05822 RA=5
05824 RB=-5
05825 CENTR=CENTR+29*RSTJ2
05826 IF(J5.EQ.-1)GO TO 8
05828 CENTR=CENTR+5*RSTJ2
05830 RA=3
05835 RB=-7
05840 C THESE FOR WHOLE RESTS. ABOVE FOR 1/2.
05860 8 IF(R4.GE.RA)GO TO 7
05865 IF(R4.GT.RB)GO TO 6
05870 7 IF(R9.NE.0)GO TO 6
05875 C P9≠0 SUPRESSES LEDGER LINE.
05877 RA=R3-7*RSTJ2
05878 RB=R3+22*RSTJ2
05880 CALL LINX(RA,CENTR,RB,CENTR)
05885
05990 6 IF(IPLT.GE.0)GO TO 1
06000 IF(J5)GO TO 1
06100 L=L+1
06200 CALL FILLMS(MR(L),IRST(MF(L)),R3,CENTR,1.,1.)
06300 C WHY GO THROUGH NOTWRT??
06400 1 IF(R8.EQ.0)RETURN
06500 C TO PUT NUM OVER REST - MULTIPLE BARS.(R8=-1 =NO NUM. OVER WHOLE RST)
06600 R4=R4+10.6
06700 C HEIGHT ??
06800 IF(IPLT)GO TO 3
06900 R6=5.96*R6
07000 C USE PARAM 6 TO CHANGE SIZE OF CENTERING AID LINE.
07100 IF(R6.EQ.0)R6=55.
07200 CALL LINX(R3-R6,CENTR,R3+R6+16.0*RSTJ2,CENTR)
07300 C HORIZ. LINE FOR CENTERING ON DPY ONLY. WILL NOT PRINT!
07400 C NEXT IS J3
07500 3 JQ(1)=ROFF(R3+8.*RSTJ2)
07600 R5=R8
07700 R6=1.5
07800 C NUMBER SIZE
07900 R8=0
08000 C ↑↑↑↑↑ ALL THIS BECAUSE OF PARAM NUMS IN MAKNUM AND NOTWRT
08100 R7=0
08200 C FOR BDR40 FONT
08300 IF(R5.GT.0)CALL MAKNUM(R5)
08400 J5=0
08500 R7=0
08600 C ↑↑↑↑↑ NEEDED??
08700 END
08800
08900 C READS DATA
09000 C FOR SINGLE (OR DOUBLE) BAR REPEAT SIGN
09100 SUBROUTINE BREP
09200 DIMENSION IREP(35)
09300 COMMON R2,JA,CENTR,J2,R3,RJQ(39) /STF/RSTFAC(8),RSTJ2
09400 DATA IREP/35,100000015,280043,290043, 10015, 20015, 300043,310043
09500 1,30015, 40015, 320043,100020037, 30038, 40038, 50037
09600 1,50036, 40035, 30035, 20036, 20037, 50037, 20036, 40036
09700 1,100270022,280021,290021,300022,300023,290024,280024,270023
09800 1,270022, 300022, 270023, 290023/
09900 CALL CENTER(R)
10000 CALL JDRAW(IREP,R3,R,RSTJ2,1.,1.)
10100 END
10200
10300 SUBROUTINE FERMTA
10400 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
10500 COMMON /PLTR/IPLT,RHT,DIS /ALF/INP(49),RMINI,RINV,NO(22)
10510 EQUIVALENCE(J5,JQ(3)),(R4,RJQ(2)),(R7,RJQ(5)),(ISTEM,JQ(20))
10520 1,(R6,RJQ(4)),(R8,RJQ(6)),(R3,RJQ(1))
10530 1,(R9,RJQ(7)),(RA,JQ(4)),(RX4,JQ(19))
10600 DIMENSION JFERM(45)
10700 DATA JFERM/24,310020003,10010010,20015,60017,110017,160015,
10800 1 190010,200003,170010,150012,120014,70014,30012,10010,
10900 1 10020003,100070007,80008,100008,110007,110006,100005,80005
11000 1 ,70006, 20,100081006, 80012, 90012, 91006, 110030002, 30008,
11100 1 70002,130008,170002, 200005, 200170002,141001,100005,130008,
11200 1 170002, 100070002, 41001, 5, 30008, 70002/
11210
11230 C 22-25, 27-29 AVAILABLE YET. (3/76)
11240 IF(J5.NE.21)GO TO 6
11250 C NEXT FOR HEAVY WEDGE ACCENT
11260 J5=44
11270 C TO BE FOUND IN 'CLEF4.DMD'
11280 R6=1
11290 RA=1.8
11300 IF(ISTEM.EQ.1)R7=-1
11310 C 2= STEM DOWN
11320 IF(R7)RA=-7.7
11340 R4=RX4+RA
11350 R8=0
11360 R9=0
11370 CALL CLEFS
11380 RETURN
11460 6 IF(RINV.LT.17)GO TO 1
11470 JFERM(29)=16
11500 JFERM(35)=210005
11600 IF(RINV.NE.17)GO TO 2
11700 JFERM(29)=91006
11800 J=25
11900 GO TO 4
12000 2 JFERM(29)=16
12100 C FOR INVERTED MORDANT
12200 J=29
12300 4 RINV=1.
12400 GO TO 3
12500 1 J=1
12600 3 CALL JDRAW(JFERM(J),R3,CENTR,RMINI,1.,RINV)
12700 IF(IPLT.GE.0)RETURN
12800 IF(J.EQ.1)GO TO 5
12900 J=35
13000 JFERM(35)=10
13100 5 CALL FILLMS(JFERM(J),JFERM(J+1),R3,CENTR,1.,RINV)
13200 END
13300
13400 CC SUBROUTINE EXCH(X,Y)
13500 CC Z=X
13600 CC X=Y
13700 CC Y=Z
13800 CC END
13900 CF SUBROUTINE SORT2(RPOS,M)
14000 CF DIMENSION RPOS(2,200)
14100 CF L=2
14200 CF3 J=-1
14300 CF RX=RPOS(1,L-1)
14400 CF DO 2 K=L,M
14500 CF IF(RPOS(1,K).GE.RX)GO TO 2
14600 CF RX=RPOS(1,K)
14700 C WHY WERE ALL THE RX'S JX ????? 9/6/73
14800 CF J=K
14900 CF2 CONTINUE
15000 CF IF(J)GO TO 4
15100 CF K=L-1
15200 CF CALL EXCH(RPOS(1,K),RPOS(1,J))
15300 CF CALL EXCH(RPOS(2,K),RPOS(2,J))
15400 CF4 L=L+1
15500 CF IF(L.LE.M)GO TO 3
15600 CF END
15700
15800 CC SUBROUTINE NOZERO(X)
15900 CC IF(X.EQ.0)X=1
16000 CC END
16100
16200 SUBROUTINE PNUM
16300 COMMON R2,JA,CENTR,J2,R3,R4,R5,R6,RJQ(16),J3,J4,J5,J6,J7,
16400 1 J10J,IPUNC,DONT,RXX,RX,JQ(10) /STF/RSTFAC(-3/4),RSTJ2
16500 DIMENSION NUMQ(44),RNUMS(341)
16600 DATA
16700 1 NUMQ/1,11,15,23,33,38,47,57,62,79, 89,95,108,117,125,132,138
16800 1,150,157,164,171,177,181,187,1,192,200,212,221,234,239,246
16900 1,250,256,261,266, 271,282,285,293,298,314,330,335/
17000 DATA (RNUMS(K),K=1,131)/10.0,1003.107, 6.102, 6.01, 3.015,
17100 1 104.015, 107.01,107.102, 104.107, 3.107,
17200 1 14.0, 1105.011, 101.015, 101.107, 22.0,
17300 1 1106.011, 102.015, 3.015, 7.011, 7.005, 107.107, 7.107, 32.0,
17400 1 1107.015, 7.015, 101.007, 3.007, 7.003, 7.102, 3.107, 103.107,
17500 1 107.103, 37.0, 1007.102, 107.102, 2.015, 2.107, 46.0, 1107.107,
17600 1 4.103, 7.0, 7.004, 2.006, 107.004, 107.015, 7.015, 56.0,
17700 1 1004.015, 107.0, 107.103, 103.107, 4.107, 7.103, 7.0, 3.003,
17800 1 104.003, 61.0, 1107.011, 107.015, 7.015, 107.107, 78.0, 1003.004,
17900 1 7.0, 7.103, 4.107, 104.107, 107.103, 107.0, 103.004, 3.004,
18000 1 6.008, 6.012, 2.015, 102.015, 106.012, 106.008, 103.004,
18100 1 88.0, 1104.107, 7.008, 7.011, 4.015, 104.015, 107.011, 107.008,
18200 1 103.005, 4.005, 94.0, 1106.107, 0.015,6.107,1004.101,104.101,
18300 1 107.0, 1106.107, 106.015, 3.015, 6.012, 6.007, 3.004, 1106.004,
18400 1 2.004, 6.001, 6.104, 3.107, 106.107, 116.0, 1006.104, 3.107,
18500 1 103.107, 106.104, 106.011, 103.015, 3.015, 6.011, 124.0,
18600 1 1106.107, 106.015, 3.015, 6.011, 6.103, 3.107, 106.107,
18700 1 131.0, 1006.107, 106.107, 106.015, 6.015, 1003.005, 106.005/
18800 C THE NEXT IS FOR 'F' TO 'P'
18900 C 1 NUM NOT NEEDED IN 'G' ALSO IN RNOTE (1/2 NOTE).
19000 DATA (RNUMS(K),K=132,199)/
19100 1 137.0, 1106.107, 106.015, 6.015, 1003.005, 106.005, 149.0,
19200 1 1001.102, 6.102, 6.104, 6.104, 3.107, 103.107, 106.104,
19300 1 106.011, 103.015, 3.015, 6.011, 156.0, 1106.107, 106.015,
19400 1 1006.015, 6.107, 1006.005, 106.005, 163.0, 1106.107, 0.107,
19500 1 1103.107, 103.015, 1106.015, 0.015,
19600 1 170.0, 1110.102, 110.105, 108.107, 103.107, 101.105, 101.015,
19700 1 176.0, 1106.107, 106.015, 1006.015, 106.005, 6.107, 180.0,
19800 1 1006.107, 106.107, 106.015, 186.0, 1106.107, 106.015, 1.004,
19900 1 8.015, 8.107, 191.0, 1106.107, 106.015, 6.107, 6.015, 199.0
20000 1, 1106.107, 106.015, 3.015, 6.012, 6.007, 3.004, 106.004/
20100 C 'Q' TO ')'
20200 DATA(RNUMS(K),K=200,341)/
20300 1 211.0, 1003.107, 6.102, 6.01, 3.015, 103.015, 106.01, 106.102,
20400 1 103.107, 3.107, 1001.001, 7.108, 220.0, 1106.107, 106.015,
20500 1 3.015, 6.012, 6.007, 3.004, 106.004, 6.107, 233.0, 1106.104,
20600 1 103.107, 3.107, 6.104, 6.001, 3.004, 103.004, 106.007, 106.011,
20700 1 103.015, 3.015, 6.01, 238.0, 1106.015, 7.015, 1000.015, 0.107,
20800 1 245.0, 1106.015, 106.104, 103.107, 3.107, 6.104, 6.015, 249.0,
20900 1 1106.015, 0.107, 6.015, 255.0, 1106.015, 103.107, 1.005, 5.107,
21000 1 8.015, 260.0, 1106.015, 6.107, 1106.107, 6.015, 265.0, 1106.015,
21100 1 0.003, 1106.107, 6.015, 270.0, 1106.015, 6.015, 106.107, 6.107,
21200 1 281.0, 1105.102, 105.105,103.105,104.102,104.105,105.102,103.102,
21300 1103.108, 106.112, 1106.112, 284., 1110.003, 2.003, 292., 1105.102,
21400 1 105.105,104.102,104.105,103.102,103.105,105.102,297.0,1110.007,
21500 1 2.007, 1110.0, 2.0, 313.0, 1101.015, 103.013, 105.010,
21600 1 106.006,106.002,105.102,103.105,101.107, 103.104,104.102,105.002
21700 1 ,105.006,104.01,103.012,101.015, 329.0,1107.015,105.013,
21800 1 103.01 ,102.006,102.002,103.102,105.105,107.107, 105.104,104.102
21900 1 ,103.002,103.006,104.01,105.012,107.015, 334.0,1110.003,
22000 1 2.003, 1104.009, 104.103, 341.0,1110.004, 2.004, 1101.009,
22100 1 107.101, 1101.101, 107.009/
22200 C 3RD ITEM IN 19400 NOT NEEDED 12/73
22300 C 1-10=NUMS 0-9, 11-36=ALPHA, 37-42=SIGNS
22400
22500 CALL CENTX
22600 J10J=J5
22700 CALL NOZERO(R6)
22800 SIZ=R6*RSTJ2
22900 IPUNC=0
23000 IF(J10J.LT.44)GO TO 451
23100 IPUNC=J10J
23200 IF(J10J.EQ.44)J10J=38
23300 IF(J10J.GE.45)J10J=36
23400 IF(J5.NE.46)GO TO 451
23500 RXX=4
23600 CALL RJBX(-RXX)
23700 RX=16
23800 CENTR=CENTR+RX*SIZ
23900 451 IX=NUMQ(J10J+1)
24000 C IX=END # OF ITEM
24100 C IX+1=1ST PART OF ITEM
24200 CALL RDRAW(IX+1,RNUMS(IX),RNUMS,SIZ,R3,CENTR+RSTJ2*3.,SIZ)
24300 IF(IPUNC.EQ.0)RETURN
24400 IF(IPUNC.NE.46)GO TO 351
24500 CALL RJBX(SIZ*2.*RXX)
24600 C FOR "
24700 651 IPUNC=0
24800 GO TO 451
24900 351 RXX=11
25000 C FOR : AND ;
25100 CENTR=CENTR+RXX*SIZ
25200 J10J=38
25300 GO TO 651
25400 END